home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / back_end / live.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  12.5 KB  |  316 lines
  1. (herald (back_end live)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define (analyze top-node)
  30.   (analyze-top top-node)
  31.   (live-analyze-top top-node)
  32.   (collect-top top-node)
  33.   (bind ((*noise-flag* t))
  34.     (print-variable-info *unit-variables*))
  35.   (type-analyze-top top-node)
  36.   (rep-analyze-top top-node)
  37.   (close-analyze-top top-node nil))
  38.  
  39.  
  40.  
  41. ;;; Live variable analysis
  42.  
  43. (define (live-analyze-top node)
  44.   (live-analyze (car (call-args (lambda-body node)))))
  45.                 
  46.      
  47. (define (live-analyze node)
  48.   (cond ((lambda-node? node)
  49.          (if (labels-master-lambda? node)
  50.              (live-analyze-y node)
  51.              (live-analyze-lambda node)))
  52.         ((leaf-node? node)
  53.          (live-analyze-leaf node))
  54.         (else
  55.          (bug "live-analyze called on a call-node ~S" node))))
  56.                                          
  57. (define (live-analyze-lambda node)
  58.   (receive (live global? known) (live-analyze-body (lambda-body node))
  59.    (let* ((live-1 (set-difference live (lambda-all-variables node)))
  60.            (live (if (neq? (node-role node) call-proc)  ;; Let
  61.                      live-1       
  62.                      (set-difference live-1 (map (lambda (node) 
  63.                                             (and (lambda-node? node)
  64.                                                  (lambda-self-var node)))
  65.                                           (call-args (node-parent node)))))))
  66.     (set (lambda-live node) live)
  67.     (select (lambda-strategy node)
  68.       ((strategy/heap)    
  69.        (walk maybe-change-to-heap known)
  70.        (cond ((and (null? live) (not (known-lambda? node)))
  71.               (set (lambda-env node) 'unit-internal-closure)
  72.               (return live t known))
  73.              (global? 
  74.               (set (lambda-env node) 'unit-internal-template)
  75.               (return live t known))
  76.              (else
  77.               (set (lambda-env node) nil)
  78.               (return live nil known))))
  79.       ((strategy/label)                
  80.        (if (and (labels-lambda? node)
  81.                 (not (ezclose-allowed? node)))
  82.            (walk change-to-vframe-or-heap (delq node known)))
  83.        (set (lambda-env node) (if global? 'needs-link '#f))
  84.        (return live global? known))
  85.       ((strategy/ezclose)
  86.        (walk maybe-cons-on-stack known)
  87.        (set (lambda-env node) (if global? 'needs-link '#f))
  88.        (return live global? known))
  89.       ((strategy/vframe)
  90.        (walk maybe-change-to-vframe known)
  91.        (set (lambda-env node) (if global? 'needs-link '#f))
  92.        (return live global? known))
  93.       ((strategy/hack)
  94.        (walk change-to-vframe-or-heap known)
  95.        (set (lambda-env node) (if global? 'needs-link '#f))
  96.        (return live global? known))
  97.       ((strategy/stack)           
  98.        (walk maybe-cons-on-stack known)
  99.        (set (lambda-env node) (if global? 'needs-link '#f))
  100.        (hoist-continuation node)
  101.        (return '() nil known))
  102.       (else
  103.        (return live global? known))))))
  104.  
  105. (define (need-to-pop-stack? y-node)                         
  106.   (and (leaf-node? ((call-arg 1) y-node))
  107.        (iterate loop ((node (node-parent y-node)))
  108.          (cond ((not (continuation? node)) nil) 
  109.                ((eq? (lambda-strategy node) strategy/stack) t)
  110.                (else (loop (node-parent (node-parent node))))))))
  111.                                                              
  112. (define (maybe-cons-on-stack l) 
  113.   (and (lambda-live l) 
  114.        (eq? (lambda-strategy l) strategy/label)
  115.        (set-label-strategies (node-parent (node-parent l))
  116.                              (cond ((ezclose-allowed? l)
  117.                                     strategy/ezclose)
  118.                                    ((and (cdr (lambda-live l))
  119.                                          (vframe-allowed? l))
  120.                                     strategy/vframe)
  121.                                    (else
  122.                                     strategy/label)))))
  123.  
  124. (define (change-to-vframe-or-heap l)
  125.   (if (neq? (lambda-strategy l) strategy/heap)
  126.       (set-label-strategies 
  127.        (node-parent (node-parent l))
  128.        (if (or (vframe-allowed? l)
  129.                (ezclose-allowed? l))
  130.             strategy/vframe 
  131.             strategy/heap))))
  132.  
  133. (define (maybe-change-to-vframe l)
  134.   (if (eq? (lambda-strategy l) strategy/ezclose)
  135.       (set-label-strategies (node-parent (node-parent l)) strategy/vframe)))
  136.       
  137.  
  138. (define (maybe-change-to-heap l) 
  139. ;  (and (or (lambda-live l) 
  140. ;           (neq? (lambda-strategy l) strategy/label))
  141.        (set-label-strategies (node-parent (node-parent l))
  142.                              strategy/heap))
  143.   
  144.  
  145. (define (set-label-strategies node strategy)
  146.   (walk (lambda (l) (set (lambda-strategy l) strategy))
  147.         (cdr (call-args (lambda-body node))))
  148.   (set (lambda-strategy node) strategy))
  149.  
  150.  
  151. (define (live-analyze-leaf node)
  152.   (cond ((literal-node? node)
  153.          (cond ((or (addressable? (leaf-value node))
  154.                     (primop? (leaf-value node)))
  155.                 (return '() nil '()))
  156.                (else
  157.                 (return '() t '()))))
  158.         ((primop-node? node)
  159.          (cond ((foreign-name (primop-value node))
  160.                 (return '() t '()))
  161.                (else 
  162.                 (return '() nil '()))))
  163.         ((variable-known (reference-variable node))
  164.          => (lambda (label)
  165.               (select (lambda-strategy label)
  166.                 ((strategy/label)
  167.                  (return (lambda-live label)
  168.                          (eq? (lambda-env label) 'needs-link)
  169.                          (if (let-lambda? label) 
  170.                              '()  
  171.                              (list label))))
  172.                 ((strategy/vframe) 
  173.                  (return `(,(lambda-self-var (node-parent (node-parent label))))
  174.                           nil
  175.                           (list label)))
  176.                 ((strategy/ezclose)
  177.                  (return '() nil (list label)))
  178.                 ((strategy/stack)
  179.                  (return '() nil '()))
  180.                 (else 
  181.                  (if (eq? (lambda-env label) 'unit-internal-closure)
  182.                      (return '() t '())
  183.                      (return `(,(lambda-self-var label)) nil '()))))))
  184.         ((bound-to-continuation? (reference-variable node))
  185.          (return '() nil '()))
  186.         ((variable-binder (reference-variable node))
  187.          (return `(,(reference-variable node)) nil '()))
  188.         (else 
  189.          (return '() t '()))))
  190.  
  191. (define (known-lambda? node)
  192.   (let ((p (node-parent (node-parent node))))
  193.     (cond ((node-parent p)
  194.            => (lambda (p)
  195.                 (and (primop-node? (call-proc p))
  196.                      (eq? (primop-value (call-proc p)) primop/Y))))
  197.           (else nil))))
  198.  
  199.  
  200. (define (live-analyze-body node)
  201.   (iterate loop ((args (if (lambda-node? (call-proc node))  
  202.                            (reverse (call-proc+args node))        ; let lambda last!
  203.                            (call-proc+args node)))
  204.                  (live '()) 
  205.                  (global? nil) 
  206.                  (known '()))
  207.     (cond (args
  208.            (receive (vars gl? kn) (live-analyze (car args))
  209.              (loop (cdr args) 
  210.                    (union vars live) 
  211.                    (or global? gl?)
  212.                    (union kn known))))
  213.           ((call-hoisted-cont node)
  214.            => (lambda (l)
  215.                 (return (union live (lambda-live l))
  216.                         (or global? (eq? (lambda-env l) 'needs-link))
  217.                         known)))
  218.           (else
  219.            (return live global? known)))))
  220.                                        
  221.  
  222. (define (live-analyze-Y master)
  223.   (if (and (not (lambda-db master))
  224.            (eq? (lambda-strategy master) strategy/label))
  225.       (set (lambda-db master) (vframe-or-ezclose master)))
  226.   (destructure (((body-expr . label-exprs) (call-args (lambda-body master)))
  227.                 (strategy (lambda-strategy master)))
  228.     (receive (global? known) (set-label-live label-exprs)
  229.       (receive (l gl? kn) (live-analyze-lambda body-expr)
  230.         (if (neq? (lambda-strategy master) strategy)
  231.             (live-analyze-y master)
  232.             (do ((exprs label-exprs (cdr exprs))
  233.                  (live l (union live (lambda-live (car exprs)))))
  234.               ((null? exprs)          
  235.                (return (set-difference (delq! (lambda-self-var master) live)
  236.                                 (map lambda-self-var label-exprs))
  237.                        (or global? gl?)
  238.                        (set-difference (union known kn) label-exprs)))))))))
  239.  
  240.  
  241.  
  242. (define (set-label-live label-exprs)
  243.   (iterate again ()
  244.     (iterate loop ((lambdas label-exprs) 
  245.                    (changed? nil) 
  246.                    (global? nil) 
  247.                    (known '()))
  248.       (cond ((not (null? lambdas))           
  249.              (let ((old-live (lambda-live (car lambdas)))
  250.                    (old-global? (true? (lambda-env (car lambdas)))))
  251.                (receive (live gl? kn) (live-analyze-lambda (car lambdas))
  252.                  (cond ((and (set-eq? old-live live)
  253.                              (eq? gl? old-global?))
  254.                         (loop (cdr lambdas) 
  255.                               changed? 
  256.                               (or global? gl?)
  257.                               (union kn known)))
  258.                        (else
  259.                         (loop (cdr lambdas) 
  260.                               t 
  261.                               (or global? gl?)
  262.                               (union kn known)))))))
  263.             (changed?
  264.              (again))
  265.             (else
  266.              (return global? known))))))
  267.  
  268. (define (hoist-continuation cont)
  269.   (let* ((call (node-parent cont))
  270.          (live (hack-live (lambda-live cont) call)))
  271.   (iterate loop ((call call))
  272.     (let ((l (node-parent call)))       
  273.       (cond ((or (primop-ref? (call-proc (node-parent l))
  274.                   primop/remove-state-object)
  275.              (neq? (lambda-strategy l) strategy/open)
  276.                  (intersection? (lambda-variables l) live)
  277.                  (eq? (node-role l) call-proc)
  278.                  (fxn= (call-exits (node-parent l)) 1))
  279.              (set (call-hoisted-cont call) cont))
  280.             (else
  281.              (loop (node-parent l))))))))
  282.  
  283. (define (hack-live live call)
  284.   (do ((args (cdr (call-args call)) (cdr args))
  285.        (live live (if (and (lambda-node? (car args))
  286.                            (eq? (lambda-strategy (car args)) strategy/hack))
  287.                       (union live (lambda-live (car args)))
  288.                       live)))
  289.     ((null? args) live)))
  290.  
  291.              
  292. (define (collect-top node)
  293.   (set *unit-literals* '())
  294.   (set *unit-variables* '())
  295.   (collect (car (call-args (lambda-body node)))))
  296.  
  297. (define (collect node)
  298.   (cond ((lambda-node? node)
  299.          (walk collect (call-proc+args (lambda-body node))))
  300.         ((literal-node? node)
  301.          (let ((lit (literal-value node)))
  302.            (or (addressable? lit)
  303.                (primop? lit)
  304.                (memq? lit *unit-literals*)
  305.                (push *unit-literals* lit))))
  306.         ((primop-node? node)
  307.          (let ((prim (primop-value node)))
  308.            (and (foreign-name prim)
  309.                 (not (memq? prim *unit-literals*))
  310.                 (push *unit-literals* prim))))
  311.         (else 
  312.          (let ((var (reference-variable node)))
  313.            (or (variable-binder var)
  314.                (memq? var *unit-variables*)
  315.                (push *unit-variables* var))))))
  316.